perm filename ORDNT.F4[P11,LCS] blob sn#587479 filedate 1981-05-16 generic text, type T, neo UTF8
C**** ORDNT, LDGLN, TAILS, DOTIT, SAVEM, GETEM ****
	SUBROUTINE ORDNT
	COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
	COMMON/DAT/RACNT(69),RDOT(17),JXAC(7),RNOTE(22)
	COMMON /STF/RSTFAC(0/7),RSTJ2 /WIDTH/WID1,WID2,WIDX
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
	COMMON/PLTR/IPLT,RHT,DIS /POSI/STFF(0/7),JJ2,POS
C  ITEMS IN FOLLOWING COMMON BLOCK ARE USED IN 'TAILS' AND 'FERM'
	COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
	1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ
	EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R4,RJQ(2))
	1,(R6,RJQ(4)),(J7,JQ(5)),(J6,JQ(4)),(R5,RJQ(3))
 	1,(R8,RJQ(6)),(R7,RJQ(5)),(R3,RJQ(1)),(RLVL,RJQ(20))
	RB=RMINI+RMINI
C RB SETS SOURCE FOR STEM
	WIDX=WID1
C GET STANDARD NOTE WIDTH
	IF(J6.LT.0)WIDX=WID2
C P6<0 = WHITE NOTE
C GETS WIDTH OF NOTE DISPLACEMENT
	RQ=WIDX
	IF(JWHOLE.LT.10)GO TO 1
C SHIFT NOTE TO LEFT OR RIGHT OF STEM (R6=20,10)
C P6 FOR HOMING TO RIGHT(10) OR LEFT(20) OF STEM(10=UP, 20=DOWN)
	IF(JWHOLE.EQ.20)RQ=-RQ
	R3=R3+RQ*RMINI
1	IF(J6.GE.0)GO TO 125
	KL=1
	RG=7.  
C  FOR WHITE NOTES ON DPY.
	J7=MOD(J7,10)
	IF(J7.EQ.0)GO TO 12122
	IF(JTAIL.NE.0)JSTEM=-JSTEM
C SAVE NEG. STEM DIRECTION FOR MARKS ROUTINE
	JTAIL=0
	IF(IPLT.LT.0)GO TO 2121
	IF(J7.NE.2)GO TO 1253
C NO DOTTED DOUBLE WHOLE NOTE??
	RQ=POS-18.*RSTJ2+RST7*(RLVL-1.)
CC	RQ=POS-18.*RSTJ2+RST7*(R4-1.)
	CALL LINX(R3,RQ,R3,RQ+RST7+RST7)
C PUT IN LINE TO SHOW DBL WHOLE ON SCREEN (P7=2)
C SET STEM SHIFT FLAG(J6) FOR ORD. WIDTH NOTES.
12122	IF(IPLT.GE.0)GO TO 1253
2121	J5=15+J7
C IF J7=1, THEN WHOLE NOTE SHAPE INSTEAD OF HALF. (J7=2=DBL. WHL.)
12121	RG=RSTJ2
C   RG  FOR NOW ;FIX THIS SOME DAY↓↓  SEE 1342+1!
	JX4=J4
	RQ=R7
	 CALL DRWNT 
C SAVE IT FOR DOTS  
C DO I NEED TO NOW?
	R7=RQ
CC	R4=RX4
	J4=JX4
C   GET 'EM BACK
	RSTJ2=RG
C DRAWS GOOD NOTES ON PLOTTER, NOT ON DPY
	RETURN
1251	CALL NOIR(RMINI)
C   FOR QUARTER NOTES ON PLOTTER.
	RETURN
125	IF(IPLT.LT.0)GO TO 1251
	RG=22.
	KL=17
1253	CALL RDRAW(KL,RG,RNOTE,RMINI,R3,CENTR,RMINI)
	END

C*********  FOR LEDGER LINES  *********
	SUBROUTINE LDGLN
	COMMON /STF/RSTFAC(0/7),RSTJ2
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/POSI/STFF(0/7),JJ2,POS
C  ITEMS IN FOLLOWING COMMON BLOCK ARE USED IN 'TAILS' AND 'FERM'
	COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
	1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ
	EQUIVALENCE (J4,JQ(2)),(J9,JQ(7)) ,(R3,RJQ(1)),(J6,JQ(4))
	1,(J12,JQ(10)),(RLVL,RJQ(20))
	J4=RLVL
	IF(J4.LT.2)GO TO 1
	J12=(J4+1)/2-6
C J12 FOR LEDGER LINES ABOVE STAFF
	GO TO 2
1	J12=-((3-J4)/2)
C BELOW STAFF
2	RJW=R3-7.*RMINI
	RZ=R3+20.*RMINI
	IF(J12.LT.0)GO TO 71
	JX=J12
	JRX=13
	GO TO 711
71	JRX=J12*2+3
	JX=-J12
711	RX=POS-18*RSTJ2+RST7*JRX
	IF(J6.LT.0)RZ=RZ+2*RMINI
126	CALL LINX(RJW,RX,RZ,RX)
1126	IF(JX.EQ.1)RETURN
	RX=RX+RSTJ2*14.
	JX=JX-1
	GO TO 126
	END

	SUBROUTINE TAILS
	COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /STF/RSTFAC(0/7),RSTJ2
	COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
	1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ
	EQUIVALENCE (R4,RJQ(2)),(R8,RJQ(6)),(J10,JQ(8)),(RLVL,RJQ(20))
	R=RMINI/RSTJ2
	RJW=2.*R
	R4=RLVL
	RA=1.
C   FOR VERT. SPACING OF MULTIPLE TAILS
	IF(JSTEM.NE.2)GO TO 1127
	R=-2.7-R8-R
	RJW=-RJW
	GO TO 2

1127	R=R8-3.+R
C WAS  -3.7 OR -2 BECAUSE ORIGINAL DRAWING OF TAIL WAS OFF.
	RA=-RA
2	R4=R4+R
C  R4 IS USED IN SUBR. TAIL   - R8 IS STEM EXTENSION.
	R=R8
	R8=0
127	CALL TAIL
	JTAIL=JTAIL-1
	IF(JTAIL.EQ.0)GO TO 1
	R=R+RJW
C RR8 SAVES INFO FOR MRK ROUTINE.
	R4=R4+RJW
	 GO TO 127 

1	R8=R
CC	R4=R4+2.
	IF(J10.GE.0)RETURN
C RJX,RZ MUST BE SAVED PROPERLY AFTER USE IN 'STEM'
	RJY=-19.
	RH=-RSTJ2*4.
	IF(JSTEM.EQ.1)GO TO 1327
C	IF(RA.LT.0)GO TO 1327
C   NEXT IS FOR STEM DOWN SLASH
	RJY=23.
	RH=RST7

1327	RJX=RJX-RST7
	RJY=RZ+RJY*RSTJ2
	RZ=RZ+RH
	CALL LINX(RJX,RJY,RJX+17.*RSTJ2,RZ)
C FOR SLASH ON GRACE NOTE TAIL
	END


	SUBROUTINE DOTIT
	COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
	1 /DAT/RAC(69),RDOT(17) /STF/RSF(8),RSTJ2 /WIDTH/WID1,WID2,WIDX
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /PLTR/IPLT,RHT,DIS
	COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
	1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ
	EQUIVALENCE (J4,JQ(2)),(J7,JQ(5)),(R3,RJQ(1)),(R7,RJQ(5))

C NEXT FOR NOTES DISPLACED TO LEFT OR RIGHT OF STEM
C  MOVES DOT TO RIGHT (THIS SHOULD BE WIDX - BUT OLD FILES WOULD BE WRONG.)
C**** USE WIDX IN FRANCE?
	IF(JWHOLE.EQ.20)GO TO 2
     	IF(JWHOLE.EQ.10.OR.J7.GT.100)RJX=RJX+WID1

2     RJY=CENTR+RSTJ2
      IF(MOD(J4,2).EQ.0)GO TO 108
C ON A LINE OR A SPACE?
      RX=RST7
      IF(J7.GT.100)RX=-RX
C  ADD 100 TO R7 FOR DOTS BELOW! NOTE
CC    IF(JWHOLE.GE.20.OR.J7.GT.100)RX=-RX
C PERHAPS SHOULD ALWAYS PUT DOT DOWN IF NOTE IS TO LEFT OF STEM??
      RJY=RJY+RX

108      RG=9.
	IF(IPLT.LT.0)RG=17.
C  DOESN'T FILL DOT ON DPY
	IF(JDOT.GT.10)JDOT=MOD(JDOT,10)
	R=10.*RMINI

107   CALL RDRAW(1,RG,RDOT,RMINI,RJX,RJY,RMINI)
	JDOT=JDOT-1
	IF(JDOT.EQ.0)RETURN
	RJX=RJX+R
CC	RJX=RJX+RSTJ2*10.
	GO TO 107
	END

	SUBROUTINE SAVEM
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
	COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
	1 RB,RJW,RZ,JX,RG,KL,RJAC /SAV/JJ9,RCEN,RR4,RR6,RR7,RR8,RR9
	EQUIVALENCE (R3,RJQ(1)),(R4,RJQ(2)),(RLVL,RJQ(20)),(R6,RJQ(4))
	1,(R7,RJQ(5)),(R8,RJQ(6)),(R9,RJQ(7)),(J9,JQ(7))
	RCEN=CENTR
	RR4=RLVL
	RR6=R6
	RR7=R7
	RR8=R8
	RR9=R9
	JJ9=J9
	END 

	SUBROUTINE GETEM
	COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
	COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
	1 RB,RJW,RZ,JX,RG,KL,RJAC /SAV/JJ9,RCEN,RR4,RR6,RR7,RR8,RR9
	EQUIVALENCE (R3,RJQ(1)),(R4,RJQ(2)),(RLVL,RJQ(20)),(R6,RJQ(4))
	1,(R7,RJQ(5)),(R8,RJQ(6)),(R9,RJQ(7)),(J9,JQ(7))
	CENTR=RCEN
	R3=RJAC
	RLVL=RR4
	R6=RR6
	R7=RR7
	R8=RR8
	R9=RR9
	J9=JJ9
	END